home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 2.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.4 / ice-9 / threads.scm.z / threads.scm
Text File  |  2002-07-08  |  2KB  |  78 lines
  1. ;;;;     Copyright (C) 1996, 1998 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; ----------------------------------------------------------------
  19. ;;;; threads.scm -- User-level interface to Guile's thread system
  20. ;;;; 4 March 1996, Anthony Green <green@cygnus.com>
  21. ;;;; Modified 5 October 1996, MDJ <djurfeldt@nada.kth.se>
  22. ;;;; ----------------------------------------------------------------
  23. ;;;;
  24.  
  25.  
  26. (define-module (ice-9 threads))
  27.  
  28.  
  29.  
  30. ; --- MACROS -------------------------------------------------------
  31.  
  32. (define-public (%thread-handler tag . args)
  33.   (fluid-set! the-last-stack #f)
  34.   (unmask-signals)
  35.   (let ((n (length args))
  36.     (p (current-error-port)))
  37.   (display "In thread:" p)
  38.   (newline p)
  39.   (if (>= n 3)
  40.       (display-error #f
  41.              p
  42.              (car args)
  43.              (cadr args)
  44.              (caddr args)
  45.              (if (= n 4)
  46.              (cadddr args)
  47.              '()))
  48.       (begin
  49.     (display "uncaught throw to " p)
  50.     (display tag p)
  51.     (display ": " p)
  52.     (display args p)
  53.     (newline p)))))
  54.  
  55. (defmacro-public make-thread (fn . args)
  56.   `(call-with-new-thread
  57.     (lambda ()
  58.       (,fn ,@args))
  59.     %thread-handler))
  60.  
  61. (defmacro-public begin-thread (first . thunk)
  62.   `(call-with-new-thread
  63.     (lambda ()
  64.       (begin
  65.     ,first ,@thunk))
  66.     %thread-handler))
  67.  
  68. (defmacro-public with-mutex (m . thunk)
  69.   `(dynamic-wind
  70.     (lambda () (lock-mutex ,m))
  71.     (lambda () (begin ,@thunk))
  72.     (lambda () (unlock-mutex ,m))))
  73.  
  74. (defmacro-public monitor (first . thunk)
  75.   `(with-mutex ,(make-mutex)
  76.     (begin
  77.       ,first ,@thunk)))
  78.